# map of new infections by county
ca_counties <- map_data("county") %>%
filter(region == "california")
stratified_rate_infections_lower <- stratified_rate_infections %>%
mutate(county = str_to_lower(county))
map_data <- ca_counties %>%
left_join(stratified_rate_infections_lower, by = c("subregion" = "county"))
# map
long_caption <- "The map shows that Imperial County has the highest new infections in 2023. It appears that the coastal counties may have a lower rate of new infections."
wrapped_caption <- str_wrap(long_caption, width = 50)
ggplot(map_data, aes(long, lat, group = group, fill = new_infections_per_capita)) +
geom_polygon(color = "white") +
scale_fill_viridis_c(option = "magma", limits = c(0,50), na.value = "grey") +
labs(title = "Heat Map of New Infections per Capita by County, 2023", fill = "Infection Rate", caption = wrapped_caption) +
theme_void() +
theme(
plot.title = element_text(hjust = 0.5, margin = margin(b = 10)),
legend.position = "right",
legend.title = element_text(size = 10),
legend.text = element_text(size = 8),
plot.margin = margin(t = 20, r = 20, b = 20, l = 20)
)
race_infections_table <- race_infections_clean %>%
select(County, `American Indian or Alaska Native Non-Hispanic`, `Asian Non-Hispanic’, Black Non-Hispanic`, `Hispanic (Any Race)`, `Multiracial (Two or More Above Races)`, `Total Infections per Capita per County`)
(
“American Indian or Alaska Native (Non-Hispanic)”,
“Asian (Non-Hispanic)”,
“Black (Non-Hispanic)”,
“Hispanic (Any Race)”,
“Multiracial (Two or More of Above Races)”,
“Native Hawaiian or Pacific Islander (Non-Hispanic)”
“White (Non-Hispanic)”
)
race_infections_table,
options = list(
pageLength = 15,
scrollX = TRUE,
autoWidth = TRUE
)
) %>%
formatStyle(
columns = 2,
valueColumns = 2,
color = styleEqual(race_infections_table\[8, 2\], ‘red’)
) %>%
formatStyle(
columns = 8,
valueColumns = 8,
color = styleEqual(race_infections_table\[8, 8\], ‘red’)
)
#Reformatting df for Table
race_infections_clean <- stratified_rate_infections %>%
pivot_wider(
id_cols = county,
names_from = race_ethnicity,
values_from = c("new_infections_per_capita", "pop")
)
#Renaming columns
colnames(race_infections_clean) <- c("County", "American Indian or Alaska Native (Non-Hispanic)", "Asian (Non-Hispanic)", "Black (Non-Hispanic)", "Hispanic (Any Race)", "Multiracial (Two or More of Above Races)", "Native Hawaiian or Pacific Islander (Non-Hispanic)", "White (Non-Hispanic)", "American Indian or Alaska Native (Non-Hispanic) Pop", "Asian (Non-Hispanic) Pop", "Black (Non-Hispanic) Pop", "Hispanic (Any Race) Pop", "Multiracial (Two or More of Above Races) Pop", "Native Hawaiian or Pacific Islander (Non-Hispanic) Pop", "White (Non-Hispanic) Pop")
#Adding Total per Capita for each Race/Ethnic Group Category
race_group <- c(
"American Indian or Alaska Native (Non-Hispanic)",
"Asian (Non-Hispanic)",
"Black (Non-Hispanic)",
"Hispanic (Any Race)",
"Multiracial (Two or More of Above Races)",
"Native Hawaiian or Pacific Islander (Non-Hispanic)",
"White (Non-Hispanic)"
)
race_sum <- race_infections_clean %>%
summarise(across(all_of(race_group), ~ sum(.x, na.rm = TRUE))) %>%
mutate(County = "Total per each Race/Ethnic Group")
race_infections_clean <- bind_rows(race_infections_clean, race_sum)
#Rearranging and Select the columns
race_infections_table <- race_infections_clean %>%
select(County, `American Indian or Alaska Native (Non-Hispanic)`, `Asian (Non-Hispanic)`, `Black (Non-Hispanic)`, `Hispanic (Any Race)`, `Multiracial (Two or More of Above Races)`, `Native Hawaiian or Pacific Islander (Non-Hispanic)`, `White (Non-Hispanic)`
)
#Creating Table Visualization
#Adding Bolded Values and Color
datatable(
race_infections_table,
options = list(
pageLength = 15,
scrollX = TRUE,
autoWidth = TRUE
),
caption = "Rate of Infections per Capita by Race and Ethnic Group per County"
) %>%
formatRound(columns = 2:ncol(race_infections_table), digits = 2) %>%
formatStyle(1,color="darkgreen") %>%
formatStyle(
columns = c(2, 8),
fontWeight = 'bold'
)
#Table Description: "American Indian or Alaska Native (Non-Hispanic) and White (Non-Hispanic) racial and ethnic groups have the highest per capita rates in total in California. "
# re-stratify datasets by epi week
epiweek_morbidity_infections <- morbidity_combined %>%
group_by(age_category,diagnosis_date) %>%
summarise("new_infections" = sum(new_infections),
"new_severe" = sum(new_severe)) %>%
ungroup()
## `summarise()` has grouped output by 'age_category'. You can override using the
## `.groups` argument.
age_ca_pop <- ca_pop_clean %>%
group_by(age_category) %>%
summarize(pop = sum(pop)) %>%
ungroup()
# join age datasets together
epiweek_age_joined <- left_join(epiweek_morbidity_infections,
age_ca_pop,
by = c("age_category"))
# calculate infection rates per 100 ppl for epiweek/race groups
epiweek_rates <- epiweek_age_joined %>%
mutate(new_inf_rate = round((new_infections/pop)*1000, digits=3),
new_severe_rate = round((new_severe/pop)*1000,digits=3))
# graph
epiweek_new_plot <- plot_ly(
epiweek_rates,
x = ~diagnosis_date,
y = ~new_inf_rate,
type = 'scatter',
mode = 'lines',
color = ~age_category,
legendgroup = "age",
showlegend = TRUE
)
epiweek_severe_plot <- plot_ly(
epiweek_rates,
x = ~diagnosis_date,
y = ~new_severe_rate,
type = 'scatter',
mode = 'lines',
color = ~age_category,
legendgroup = "age",
showlegend = FALSE
)
epiweek_plot <- subplot(
epiweek_new_plot,
epiweek_severe_plot,
nrows = 1,
shareX = TRUE,
titleY = FALSE,
titleX = FALSE
) %>%
layout(title = list(
text = "New and Severe Case Rates by Age",
x = 0.45, y=1.2,
xanchor = "center",
font = list(size = 16, color = "black")
),
annotations = list(
list(x = 0.15, y = 1.05, text = "New Infections",
xref = "paper", yref = "paper", showarrow = FALSE),
list(x = 0.85, y = 1.05, text = "New Severe Infections",
xref = "paper", yref = "paper", showarrow = FALSE),
list(x = 0.5, y = -0.2,
text = "Infection rates are highest between early August to late October.<br>Both new and severe infection rates are highest among those aged 65+.",
xref = "paper", yref = "paper", showarrow = FALSE)
),
margin = list(t = 70, b = 90),
yaxis = list(title = "Cases per 1000 people"),
xaxis = list(zeroline = FALSE),
legend = list(title = list(text = "Age")),
plot_bgcolor = '#e5ecf6'
)
epiweek_plot